perm filename GEMSUB[G,BGB] blob
sn#068993 filedate 1974-01-02 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00020 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 TITLE GEMSUB GEOMETRIC MODELING SYSTEM SUBROUTINES.
C00005 00003 INITIALIZE APR TRAP
C00007 00004 PRINT BACKTRACE
C00011 00005 WHAT USER CAN DO ABOUT ERROR
C00013 00006 WE GET HERE ON AT INTERRUPT
C00016 00007 HERE WE TAKE CARE OF THE UGLY OVERFLOW MESS!
C00020 00008 SUBROUTINES (WHICH USE PP INSTEAD OF P)
C00023 00009 DATA STORAGE
C00024 00010 ROUTINES TO PUSH AND POP ACCUMULATORS.
C00026 00011 TITLE ARITH - ARITHMETIC ROUTINES.
C00029 00012 SUBR(SIN)
C00031 00013 SUBR(ATAN,X) ARC TANGENT
C00034 00014 SUBR(ATAN2,DY,DX) ARC TANGENT (DELTA-Y,DELTA-X)
C00037 00015 SUBR(REALI)
C00040 00016 TITLE III - III DISPLAY SUBROUTINES - BGB - JANUARY 1973.
C00041 00017 SUBRS DPYSET,DPYBIG,DPYBRT Set buffer,char. size, brightness*
C00043 00018 SUBRS AVECT,AIVECT,RVECT,RIVECT Vectors
C00046 00019 SUBRS DPYSTR,DTYO,DPYOUT Output string,character, POG *
C00049 00020 SUBRS OCTDPY,DECDPY,FLODPY Numeric display *
C00052 ENDMK
C⊗;
TITLE GEMSUB; GEOMETRIC MODELING SYSTEM SUBROUTINES.
INTERNAL FATAL.,WARN.,TRAPINIT,PUSHIT,POPIT,DDTGO,OVRGAG
EXTERNAL PDL
EXTERNAL JOBCNI,JOBAPR,JOBTPC,JOBREL,JOBHRL,JOBDDT
EXTERNAL JOBREN,JOBOPC,JOBSA
IFNDEF JENFIX<JENFIX←←0 > ;SET TO -1 WHEN INTJEN IS FIXED
OPDEF INTJEN[723B8]
OPDEF JRSTF [JRST 2,]
CNT←14
RA←15
PP←16
P←17
INTTTI←←4000000 ; INTERRUPT ON <ESC>I
POV←←200000 ; INTERRHUPT ON PDL OV
ILM←←20000 ; INTERRUPT ON ILL. MEM. REF.
NXM←←10000 ; INTERRUPT ON NON-EX. MEM.
INTFOV←←100 ; INTERRUPT ON FOATING OVERFLOW
INTOV←←10 ; INTERRUPT ON ARITHMETIC ROVERFHLOW
OVBOTH←←INTOV+INTFOV
DEFINE INTFOR <FOR @` I ⊂ (INTTTI,POV,ILM,OVBOTH)>
;INITIALIZE APR TRAP
TRAPINIT↑:
;--------------------------------------------------------------------
LACI 0,INTLOC↔DAC 0,JOBAPR
IFN JENFIX <POP P,INTPC↔INTJEN INTWRD>
IFE JENFIX <LAC 0,INTWRD↔INTENB 0,↔POPJ P,>
XWD 777000,[SIXBIT/WARN./]
WARN.↑: SETZM NOCONT↔GO FATAL2
XWD 777000,[SIXBIT/FATAL./]
FATAL.↑:SETOM NOCONT↔SETZM ALWAYS
FATAL2: SETOM ILOCK ;INTERLOCK AGAINST INTERRUPT
IFNDEF ERRUUO<POP P,INTPC>
DAC 0,ACSAVE ;SAVE STATE OF WORLD
LAC 0,[XWD 1,ACSAVE+1]
BLT ACSAVE+17
SKIPE NOCONT↔OUTSTR[ASCIZ/FATAL: /]
SKIPN NOCONT↔OUTSTR[ASCIZ/WARNING: /]
IFDEF ERRUUO
<LAC 0,40↔OUTSTR @0
LAC 0,ERRUU.↔DAC 0,INTPC>
IFNDEF ERRUUO
<LAC 0,@1(P)↔OUTSTR @0>
DAC 0,ERRTXT
SETZ 0,
INTENB ;TURN OFF OUR ENABLINGS
SETZM ILOCK ;RESET INTERLOCK, WE'RE SAFE NOW
LAC PP,[IOWD 10,BKPDL] ;GET A TEMPORARY PDL
GO BTRACE
;PRINT BACKTRACE
COMMENT ⊗
The following routine looks down the pushdown list for
something that looks like a PC word and prints out its name if it
has an NSUBR header, otherwise it prints its address in octal. It
finds out what routine was called by looking one or more back of the
return address on the PDL. Needless to say, it can be fooled by
routines that skip return or push funny PC words on the stack. ⊗
USERMODE←←1B5 ;ALWAYS ON IN A PC
PC.OFF←←1B4+1B6+37B17 ;ALWAYS OFF IN A PC
;1B4 is byte interrupt, never in user PDL
;1B6 is IOT mode, almost never on in PDL
BTRACE: CDR P,P ;GET READY TO PRINT A BACKTRACE
OUTSTR[ASCIZ/
BACKTRACE: /]
PCLOOP: LAC RA,(P) ;PICK UP WORD OFF OF STACK AND SEE IF IT'S A PC
TLNE RA,(USERMODE) ;IS USER MODE ON?
TLNE RA,(PC.OFF) ;AND OTHER DETERMINING BITS OFF?
GO NOTPC ;NO, NOT A PC
PUSH PP,RA ;LEFT HALF GOOD, NOW, IS IT IN OUR CORE IMAGE
PUSHJ PP,ADRCHK
GO NOTPC ;NO, PROBABLY NOT A PC
LACI CNT,3 ;DON'T LOOK MORE THAN THREE BACK
OUTSTR[ASCIZ/ /]
PJLOOP: SUBI RA,1↔JUMPLE RA,UNKNPJ
CAR 0,(RA)↔CAIN 0,(<PUSHJ P,>)↔GO GOTPJ
SOJG CNT,PJLOOP
UNKNPJ: OUTSTR[ASCIZ/(?)/] ;WE DIDN'T FIND A PUSHJ, INDICATE AN UNKNOWN ROUTINE
GO NOTPC ;AND LOOK FOR MORE
GOTPJ: PUSH PP,(RA) ;WE FOUND A PUSHJ P,
PUSHJ PP,ADRCHK ;CHECK ADDRESS
GO UNKNPJ ;OOPS, PRINT BARF MESSAGE
LDB 0,[POINT 12,-1(1),11] ;LOOK BACK AT SUBROUTINE-1
CAIE 0,7770 ;IS SPECIAL MARK THERE?
GO [ LDB 0,[POINT 12,-1(1),11] ;NO, TRY BACK ANOTHER, IN CASE IT STARTS
CAIN 0,7770 ;AT SUBROUTINE+1
GO [ LAC 1,-2(1) ;SPECIAL MARK THERE
PUSH PP,(1) ;PRINT NAME+1
PUSHJ PP,SIXOUT
OUTSTR[ASCIZ/+1/]
GO NOTPC ]
PUSH PP,1 ;PRINT OCTAL OF SUBROUTINE ADDRESS
PUSHJ PP,OCTOUT
GO NOTPC ]
LAC 1,-1(1) ;PRINT NAME OF ROUTINE
PUSH PP,(1)
PUSHJ PP,SIXOUT
NOTPC: SOS P ;NOW, LETS TRY NEXT ONE DOWN
CAIL P,PDL ;END YET?
GO PCLOOP ;NO
OUTSTR[ASCIZ/
/] ;YES, CRLF
MOVSI 17,ACSAVE ;RESTORE ACS
BLT 17,16
SKIPE STAT6
SKIPN OVRGAG
GO CMLOOP ;WE COULD FALL THRU BUT THIS IS SAFER
OUTSTR[ASCIZ/(By the way, the PDP-6 is down.)
/]↔ SETZM STAT6
GO CMLOOP
;WHAT USER CAN DO ABOUT ERROR
;
CMLOOP: SKIPN NOCONT
GO [ SKIPE ALWAYS↔GO CONT
OUTSTR [ASCIZ/→/]
GO CMLOO2]
OUTSTR [ASCIZ/?/]
CMLOO2: CLRBFI ;NO TYPE AHEAD, THANK YOU
INCHRW 17↔ANDI 17,137 ;WHAT DOES USER WANT TO DO
CAIN 17,"R"↔GO @JOBREN
CAIN 17,"S"↔GO [ CDR 17,JOBSA↔GO (17) ]
CAIN 17,"D"↔GO DDTCALL
CAIN 17,"α"↔GO CONT
SKIPE NOCONT↔GO NOTCOM
CAIN 17,12
CAIE 17,15
GO [ CAIN 17,12↔SETOM ALWAYS
CONT: SETZM ILOCK↔GO INTRT2 ]
NOTCOM: OUTSTR[ASCIZ/???
D - DDT, R - REENTER, S - START/]
SKIP NOCONT
OUTSTR[ASCIZ/, <RETURN> CONTINUE
/]↔ OUTSTR[ASCIZ/
/]↔ OUTSTR @ERRTXT
GO CMLOOP
;SEE IT DDT IS LOADED AND RUN IT
DDTCALL:SKIPN 17,JOBDDT
GO [ OUTSTR[ASCIZ/
NO DDT.
?/]↔ GO CMLOOP ]
IFE JENFIX
< SETOM ILOCK ;WATCH THE RACE CONDITION
LAC 17,INTPC
DAC 17,JOBOPC
OUTSTR[ASCIZ/
YOU'RE IN DDT.
/]
LAC 17,INTWRD
INTENB 17,
LAC 17,ACSAVE+17
SETZM ILOCK ;WATCH THE RACE CONDITION
GO @JOBDDT
>
OUTSTR [ASCIZ/
YOU'RE IN DDT.
/]
IFN JENFIX
< LAC 17,ACSAVE+17
INTJEN INTWRD
>
;WE GET HERE ON AT INTERRUPT
;
INTLOC: SETZ ;TURN OFF INTERRUPTS, JUST IN CASE!
INTENB
DAC 5,STAT6 ;REMEMBER THE STATUS OF PDP-6
LAC 0,JOBCNI ;HOW DID WE GET HERE?
INTFOR
<IFE I∧777777 < TLNE 0,(I)
>IFN I∧777777 < TRNE 0,I
> GO [ LACI .`I
JRST USRRET ]
>
LACI .UNKNOWN
USRRET: DAC PCGO
SKIPE ILOCK
GO ILOSE
UWAIT ;WHEN WE RETURN, WE'LL GET OUR AC'S BACK
DAC 0,ACSAVE
LAC 0,JOBTPC↔TLNN 0,USERMODE↔SETOM BAZFLG#↔DAC 0,INTPC
LAC 0,[XWD 1,ACSAVE+1]
BLT 0,ACSAVE+17
DEBREAK
LAC PP,[IOWD 10,BKPDL]
JRSTF @PCGO
.POV: OUTSTR[ASCIZ/?
PDL OV/]
SOS INTPC ;INSTRUCTION WHERE IT REALLY HAPPENED
PUSHJ PP,ATUSER
GO IFATAL
.ILM: PUSH PP,INTPC
PUSHJ PP,ADRCHK
GO [ OUTSTR[ASCIZ/?
PC OUT OF BOUNDS/]
GO .ILM2 ]
;*** A PAGING ROUTINE COULD BE INCLUDED HERE ***
OUTSTR[ASCIZ/?
ILL MEM REF/]
.ILM2: PUSHJ PP,ATUSER
GO IFATAL
.INTTT: OUTSTR[ASCIZ/
<ESC> I INTERRUPT/]
PUSHJ PP,ATUSER
SETZM NOCONT
SETZM ALWAYS
GO BTRACE
.UNKNO: OUTSTR[ASCIZ/?
UNEXPECTED INTERRUPT/]
PUSHJ PP,ATUSER
GO IFATAL
IFATAL: SETOM NOCONT
SETZM ALWAYS
GO BTRACE
ILOSE: CAIN .INTTTI
GO [ LAC 0,INTWRD ;WE'RE ALREADY IN AN ERROR ROUTINE
INTENB 0,
DISMIS ]
LAC 0,JOBTPC
DAC 0,INTPC
UWAIT ;GET BACK USER ACS, ETC.
DEBREAK ;GET BACK TO USER LEVEL
OUTSTR[ASCIZ/?
INTERRUPT OCCURED DURING ERROR ROUTINE! /]
HALT .+1
JRSTF @INTPC
;HERE WE TAKE CARE OF THE UGLY OVERFLOW MESS!
;
.OVBOTH:LAC 0,INTPC
TLNE 0,000040 ;TEST ZERO DIVIDE
GO [ SKIPN OVRGAG ;DIVISION BY ZERO RESULTS IN INFINITY!
OUTSTR[ASCIZ/DIVISION BY ZERO/]
LAC 0,[377777777777]
GO FIXOVER ]
TLNE 0,000100 ;TEST FLOATING UNDERFLOW
GO [ SKIPN OVRGAG ;SET TO ZERO
OUTSTR[ASCIZ/FLOATING UNDERFLOW/]
SETZ 0,
GO FIXOVER ]
TLNE 0,040000
GO [ SKIPN OVRGAG
OUTSTR[ASCIZ/FLOATING OVERFLOW/]
LAC 0,[377777777777] ;FLOATING OVERFLOW PRODUCES INFINITY
GO FIXOVER ]
TLNN 0,400000 ;INTEGER OVERFLOW?
HALT .+1
MOVSI 1,400000
ANDCAM 1,INTPC
GO INTRET
FIXOVER:DAC 0,OVFIX
SKIPN OVRGAG
PUSHJ PP,ATUSER
MOVSI 1,440140 ;TURN OFF LOSING BITS
ANDCAB 1,INTPC
LAC 1,-1(1) ;IT HAPPENED AT PC-1
XCLOOP: LDB 2,[POINT 9,1,8] ;GET OPCODE
CAIN 2,<XCT>/1B8 ;IS IT AN XCT INSTRUCTION
GO [ TLZ 1,777400 ;TURN OFF OPCODE
TLO 1,(<LAC 1,>)
DAC 1,OVINST
MOVSI 17,ACSAVE ;YES, TRY NEXT ONE IN CHAIN
BLT 17,16
LAC 17,ACSAVE+17
XCT OVINST
GO XCLOOP ]
DAC 1,OVINST
TLZ 1,777740 ;TURN IT INTO A LACI TO CALCULATE EFFECTIVE ADDRESS
TLO 1,(<LACI 2,>)
DAC 1,OVOP
MOVSI 17,ACSAVE ;GET ACS FOR EFFECTIVE ADDRESS CALCULATION
BLT 17,16
LAC 17,ACSAVE+17
XCT OVOP ;DO ADDRESS CALCULATION, PUTTING RESULT INTO AC.2
CAIGE 2,17 ;IN CASE THE EFFECTIVE ADDRESS IN AN AC
ADDI 2,ACSAVE ;POINT TO SAVED ACS
LDB 3,[POINT 4,OVINST,12];GET AC FIELD INTO AC.3
ADDI 3,ACSAVE ;POINT TO SAVED ACS
LDB 1,[POINT 9,OVINST,8];GET OPCODE
LAC 0,OVFIX
CAIN 1,<FSC>/1B8 ;SPECIAL TEST FOR FSC
GO [ SETZ 1, ;RESULT INTO AC.0
GO NTEST2 ]
CAILE 1,140 ;IS IT FLOATING IMMEDIATE?
CAILE 1,177
GO NTEST ;NO, NOT FLOATING
ANDI 1,7
CAIE 1,5 ;ONLY IF LOWER ORDER DIGIT=5
GO NTEST
MOVSS 2,2
SKIPGE 2
MOVN 0,0
GO NTEST2
NTEST: ANDI 1,3 ;JUST MODE BITS, PLEASE
CAIN 1,1 ;DON'T TRY TO REFERENCE MEMORY ON IMMEDIATE, PLEASE
GO NTEST2
SKIPGE (2) ;CHANGE SIGN AS IF (MEMORY)<0
MOVN 0,0
NTEST2: SKIPGE (3) ;CHANGE SIGN IF (AC)<0
MOVN 0,0
SKIPN (3) ;MAKE 0/0=0
SETZ 0,
ANDI 1,3 ;JUST MODE BITS, PLEASE
TRNE 1,2 ;DOES RESULT GO TO MEMORY?
DAC 0,(2) ;YES
CAIE 1,2 ;JUST TO MEMORY?
DAC 0,(3) ;NO
INTRET: MOVSI 17,ACSAVE
BLT 17,16
INTRT2:
IFN JENFIX
< LAC 17,ACSAVE+17
INTJEN INTWRD
>
IFE JENFIX
< LAC 17,INTWRD
INTENB 17,
LAC 17,ACSAVE+17
JRSTF @INTPC
>
;SUBROUTINES (WHICH USE PP INSTEAD OF P)
;--------------------------------------------------------------------
; Routine to check to make sure RH is in core image. Returns RH is 1
; and skips if legal address
ADRCHK: CDR 1,-1(PP)
CAMLE 1,JOBREL
GO [ CAIL 1,400000 ;(DON'T NEGLECT UPPER!)
CAILE 1,JOBHRL
GO POPP1J
GO .+1]
AOS (PP)
POPP1J: SUB PP,[XWD 2,2]↔GO @2(PP)
;--------------------------------------------------------------------
; Print a right half in octal (if called at OCTOUT+1, print left half)
OCTOUT: MOVSS -1(PP) ;LAC INTO LEFT HALF
SKIPA 4,[[ ROTC 3↔"0" ]] ;WE CAN SHARE CODE WITH SIXOUT
; Print a number in sixbit
SIXOUT: LACI 4,[ ROTC 6↔" "] ;(TO SHARE WITH OCTOUT)
LACI 3,6 ;NUMBER OF CHARACTERS
LAC 1,-1(PP) ;GET ARG.
SXLOOP: SETZ 0, ;CLEAR AC WERE ABOUT TO ROTC INTO
XCT (4) ;GET HIGH ORDER DIGIT/CHARACTER
ADD 0,1(4) ;ADD APPROPRIATE THING
OUTCHR 0 ;OUTPUT
CAIE 0," " ;TEST FOR END (FOR SIXBIT, THIS NEVER HAPPENS FOR OCTOUT)
SOJG 3,SXLOOP ;MORE TO COME
SUB PP,[XWD 2,2] ;WE'RE DONE, RETURN
JRSTF @2(PP)
;--------------------------------------------------------------------
;PRINT ' AT USER 000000'
ATUSER: PUSH PP,0 ;SAVE AC 0
OUTSTR [ASCIZ/ AT USER /]
PUSH PP,INTPC
PUSHJ PP,OCTOUT
OUTSTR [ASCIZ/
/]↔ POP PP,0↔POPJ PP,
;--------------------------------------------------------------------
;DATA STORAGE
ACSAVE: BLOCK 20
BKPDL: BLOCK 10
;INTWRD AND INTPC MUST BE IN ORDER OR INTJEN WILL LOSE!
.INTWRD←←0
INTFOR <.INTWRD←←.INTWRD!I
>
INTWRD: .INTWRD
INTPC: BLOCK 1
PCGO: BLOCK 1
ILOCK: BLOCK 1
STAT6: BLOCK 1
OVFIX: BLOCK 1
OVOP: BLOCK 1
OVINST: BLOCK 1
NOCONT: BLOCK 1
ALWAYS: BLOCK 1
OVRGAG: BLOCK 1
ERRTXT: BLOCK 1
;ROUTINES TO PUSH AND POP ACCUMULATORS.
IFNDEF PUSHIT <
↑↑PUSHIT:
PUSH P,0 ; SAVE 0
HLRE 0,P ; PICK UP COUNT
ADDI 0,20 ; ADD IN DISPLACEMENT
XOR 0,P ; IF SIGNS ARE DIFFERENT, NOT ENOUGH STACK
JUMPGE 0,PUSHOK
POP P,0 ; CAN'T DO IT, LOSE BIG
OUTSTR [ASCIZ ⊗NOT ENOUGH ROOM TO PUSH ACS!!
⊗]
SKIPN JOBDDT
GO [ OUTSTR[ASCIZ⊗YOU LOSE. ⊗]
HALT PUSHIT ]
↑↑DDTGO:OUTSTR[ASCIZ⊗YOU'RE IN DDT
⊗]
POP P,JOBOPC
GO @JOBDDT
PUSHOK: POP P,0 ; GET BACK 0
EXCH 0,(P) ;SAVE 0 AND GET RETURN.
DAC 0,20(P) ;GEE, THIS WAY WE RETURN WITH A POPJ
LACI 0,1(P)
HRLI 0,1
BLT 0,17(P)
ADD P,[XWD 20,20]
POPJ P, ;RETURN TO SENDER
↑↑POPIT:
MOVSI 0,-17(P)
HRRI 0,1
BLT 0,17
LAC 0,20(P)
EXCH 0,(P)
POPJ P,
>
;TITLE ARITH - ARITHMETIC ROUTINES.
HALFPI↑: 201622077325 ;PI/2
PI↑: 202622077325 ;PI
TWOPI↑: 203622077325 ;2*PI
SUBR(SQRT,X) ;SQUARE ROOT OF ABS(X).
COMMENT ⊗------------------------------------------------------------
⊗
A←←0 ↔ B←←1 ↔ C←←2
LACM B,X↔JUMPE B,POP1J.↔PUSHP 2
;LET X=F*(2↑2B) WHERE 0.25<F<1.00 THEN SQRT(X)=SQRT(F)*(2↑B).
ASHC B,-=27↔SUBI B,201 ;GET EXPONENT IN B, FRACTION IN C.
ROT B,-1 ;CUT EXP IN HALF, SAVE ODD BIT
DAP B,L↔LSH B,-=35 ;USE THAT ODD BIT.
ASH C,-10↔FSC C,177(B) ;0.25 < FRACTION < 1.00
;LINEAR APPROXIMATION TO SQRT(F).
DAC C,A
FMP C,[0.8125↔0.578125](B)
FAD C,[0.302734↔0.421875](B)
;TWO ITERATIONS OF NEWTON'S METHOD.
LAC B,A
FDV B,C↔FAD C,B↔FSC C,-1
FDV A,C↔FADR A,C
L: FSC A,0↔LAC 1,A↔POPP 2
POP1J
ENDR SQRT; BGB 28 DECEMBER 1972 -------------------------------------
SUBR(LOG,X) ;NATURAL LOGRITHM.
COMMENT ⊗------------------------------------------------------------
⊗
MOVM X↔SKIPE 1,0↔CAMN 0,[1.0]↔POP1J
ASHC 0,-33↔ADDI 0,211000↔MOVSM 0,TMP1#
MOVSI 0,(-128.5)↔FADM 0,TMP1
ASH 1,-10↔TLC 1,200000↔FAD 1,[-0.70710678]
LAC 0,1↔FAD 0,[1.4142135]↔FDV 1,0
DAC 1,TMP2#↔FMP 1,1
LAC 0,[0.59897864]↔FMP 0,1
FAD 0,[0.96147063]↔FMP 0,1
FAD 0,[2.88539120]↔FMP 0,TMP2↔FAD 0,TMP1
FMP 0,[0.69314718]↔LAC 1,0↔POP1J
VAR
ENDR LOG;---------------------------------------------------------
SUBR(SIN)
GO SIN.↔ENDR SIN
SUBR(COS)
GO COS.↔ENDR COS
BEGIN SINCOS ;MODIFIED OLDE LIB40 SINE & COSINE - BGB.
A←←1 ↔ B←←2 ↔ C←←3
↑COS.: SKIPA A,ARG1
↑SIN.: SKIPA A,ARG1
FADR A,HALFPI ;COS(X) = SIN(X+π/2).
MOVM B,A↔CAMG B,[17B5]↔POP1J ;FOR SMALL X, SIN(X)=X.
;B ← (ABS(X)MODULO 2π)/HALFPI
;C ← QUADRANT 0, 1, 2 OR 3.
FDVR B,HALFPI
LAC C,B↔FIX C,233000
CAILE C,3↔GO[
TRZ C,3↔FSC C,233
FSBR B,C↔GO .-3] ;MODULO 2π.
GO .+1(C)↔GO .+4↔JFCL↔GO[
FSBRI B,(2.0)↔MOVNS B↔GO .+2] ;SIN(X+π)=SIN(-X)
FSBRI B,(4.0) ;SIN(X+2π)=SIN(X)
SKIPGE A↔MOVNS B ;SIN(-X) = -SIN(X).
;FOR -1 ≤ B ≤ +1 REPRESENTING -π/2 ≤ X ≤ +π/2,
;COMPUTE SINE(X) APPROXIMATION BY TAYLOR SERIES.
DAC B,C↔FMPR B,B
LAC A,[164475536722]↔FMP A,B
FAD A,[606315546346]↔FMP A,B
FAD A,[175506321276]↔FMP A,B
FAD A,[577265210372]↔FMP A,B
FAD A,HALFPI↔FMPR A,C↔POP1J
LIT
BEND SINCOS;---------------------------------------------------------
SUBR(ATAN,X) ;ARC TANGENT
COMMENT ⊗------------------------------------------------------------
IF 0.0 < X ≤ 1.0 THEN ⊂ Z ← X*X;
RETURN (ATAN(X) = X*(B0+A1/(Z+B1-A2/(Z+B2-A3/(Z+B3)))));⊃;
IF X>1 THEN ATAN(X) = PI/2 - ATAN(1/X);
IF X>1 THEN RH(D) =-1, AND LH(D) = -SGN(X)
IF X<1, THEN RH(D) = 0, AND LH(D) = SGN(X)
⊗
A←←1 ↔ B←←2 ↔ C←←3 ↔ D←←4 ↔ E←←5
LAC A,X ;PICK UP THE ARGUMENT IN A
ATAN1: LACM B, A ;GET ABSF OF ARGUMENT
CAMG B, A1 ;IF X<2↑-33, THEN RETURN WITH...
POP1J ;ATAN(X) = X
HLLO D, A ;SAVE SIGN, SET RH(D) = -1
CAML B, A2 ;IF A>2↑33, THEN RETURN WITH
GO[LAC A,HALFPI ↔POP1J]; ATAN(X) = PI/2
MOVSI C,(<1.0>) ;FORM 1.0 IN C
CAMG B, C ;IS ABSF(X)>1.0?
TRZA D, -1 ;IF B ≤ 1.0, THEN RH(D) = 0
FDVM C, B ;B IS REPLACED BY 1.0/B
TLC D, (D) ;XOR SIGN WITH > 1.0 INDICATOR
DAC B,E↔FMP B,B
LAC C,B↔FAD C,KB3↔LAC A,KA3↔FDVM A,C
FAD C,B↔FAD C,KB2↔LAC A,KA2↔FDVM A,C
FAD C,B↔FAD C,KB1↔LAC A,KA1↔FDV A,C
FAD A,KB0↔FMP A,E
TRNE D, -1 ;CHECK > 1.0 INDICATOR
FSB A, HALFPI ;ATAN(A) = -(ATAN(1/A)-PI/2)
SKIPGE D ;LH(D) = -SGN(B) IF B>1.0
MOVNS A ;NEGATE ANSWER
POP1J ;EXIT
A1: 145000000000 ;2↑-33
A2: 233000000000 ;2↑33
KB0: 176545543401 ;0.1746554388
KB1: 203660615617 ;6.762139240
KB2: 202650373270 ;3.316335425
KB3: 201562663021 ;1.448631538
KA1: 202732621643 ;3.709256262
KA2: 574071125540 ;-7.106760045
KA3: 600360700773 ;-0.2647686202
ENDR ATAN;--------------------------------------------------------
SUBR(ATAN2,DY,DX) ;ARC TANGENT (DELTA-Y,DELTA-X)
COMMENT ⊗------------------------------------------------------------
⊗
; OMEGA ← ATAN2(Y,X).
Y←←1 ↔ X←←2
LACM Y,ARG2↔LACM X,ARG1
CAMN X,Y↔JUMPE Y,L2
CAML Y,X↔GO L1
;HORIZONTAL TO π/2; ABS(Y) < ABS(X).
LAC Y,ARG2↔FDVR Y,ARG1
PUSH 17,Y↔PUSHJ 17,ATAN ;ARCTAN(Y/X)
SKIPL ARG1↔POP2J ;1ST & 2ND QUADRANTS.
JUMPGE Y,[
FSBR Y,PI↔POP2J] ;3RD QUADRANT.
FADR Y,PI↔POP2J ;2ND QUADRANT.
;VERTICAL TO π/2; ABS(X) < ABS(Y).
L1: LACN X,ARG1↔FDVR X,ARG2
PUSH 17,X↔PUSHJ 17,ATAN ;ARCTAN(X/Y)
SKIPG ARG2↔GO[
FSB Y,HALFPI↔POP2J]
FADR Y,HALFPI
L2: POP2J
ENDR ATAN2;----------------------------------------------------------
SUBR(ASIN,X) ;ARC SINE.
COMMENT ⊗------------------------------------------------------------
ASIN(X)=ATAN(X/SQRT(1-X↑2)).
GIVEN -1 ≤ X ≤ +1 RETURN -π/2 ≤ ASIN(X) ≤ +π/2.
⊗
A←1 ↔ B←2
LACN A,X↔FMPR A,X↔FADRI A,(1.0)
JUMPE A,[LAC A,HALFPI ;WAS X EITHER -1.0 OR 1.0?
SKIPGE ARG1↔MOVNS A↔POP1J]
CALL(SQRT,A)
LAC B,X↔FDVR B,1↔DAC B,X ;CALCULATE X/SQRT(1-X↑2)
GO ATAN ;CALCULATE ATAN(SQRT(1-X↑2))
ENDR ASIN;-----------------------------------------------------------
SUBR(ACOS,X) ;ARC COSINE.
COMMENT ⊗------------------------------------------------------------
ACOS(X)= π/2 - ASIN(X).
GIVEN -1 ≤ X ≤ +1 RETURN 0 ≤ ACOS(X) ≤ +π.
⊗
CALL(ASIN,X)
MOVNS 1↔FADR 1,HALFPI
POP1J
ENDR ACOS;--------------------------------------------------------
SUBR(REALI)
COMMENT ⊗------------------------------------------------------------
<EXPR> ::= <EXPR>+<TERM>|<EXPR>-<TERM>|<TERM>
<TERM> ::= <TERM>*<PRIMARY>|<TERM>/<PRIMARY>|<PRIMARY>
<PRIMARY> ::= -<PRIMARY>|(<EXPR>)|π|<REAL NUMBER> ⊗
REAL0: CALL(TERM)↔CAIN 1,"+"↔GO[PUSH P,0
CALL(TERM)↔FADR 0,(P)
SUB P,[XWD 1,1]↔GO REAL0]
CAIN 1,"-"↔GO[PUSH P,0
CALL(TERM)↔MOVN 0,0
FADR 0,(P)
SUB P,[XWD 1,1]↔GO REAL0]
CAIN 1,15↔CALL(GETCHL)
POP0J↔POP0J
;--------------------------------------------------------------------
TERM: CALL(PRIMARY)
TERM2: CAIN 1,"*"↔GO[PUSH P,0
CALL(PRIMARY)↔FMPR 0,(P)
SUB P,[XWD 1,1]↔GO TERM2 ]
CAIN 1,"/"↔GO[PUSH P,0
CALL(PRIMARY)↔EXCH 0,(P)
FDVR 0,(P)
SUB P,[XWD 1,1]↔GO TERM2 ]
POPJ P,
;--------------------------------------------------------------------
COMMENT ⊗ Input small real number.
AC-0 INTEGER ACCUMULATION. AC-0 RETURNS REAL NUMBER.
AC-1 CHARACTER. AC-1 RETURNS BREAK CHARACTER.
AC-2 COUNTER OF DIGITS TO RIGHT OF DECIMAL POINT PLUS ONE.
AC-3 MINUS SIGN FLAG.
;-------------------------------------------------------------------⊗
PRIMARY:SETZ↔SETZB 2,3
L0: CALL(GETCHL↑)
CAIN 1," "↔GO .-2
CAIN 1,"-"↔GO[SETCMM 3↔GO L0]
CAIN 1,"π"↔GO[LAC 0,PI
GETRET: CALL(GETCHL)↔GO L3]
CAIN 1,"("↔GO[PUSH P,3↔CALL(REALI)↔POP P,3
CAIN 1,")"↔GO GETRET
OUTSTR[ASCIZ/WARNING: MISSING ')'
/]↔ POPJ P,]
SKIPA
L1: CALL(GETCHL)
CAIE 1,"."↔GO .+3↔JUMPN 2,L2↔AOJA 2,L1
CAIL 1,"0"↔CAILE 1,"9"↔GO L2
JUMPN 2,[CAILE 2,4↔GO L1↔AOJA 2,.+1]
ANDI 1,17↔IMULI =10↔ADD 1↔GO L1
L2: FLOAT↔SOSLE 2↔FDVR[1.0↔10.0↔100.0↔1000.0↔10000.0](2)
L3: SKIPE 3↔MOVNS↔POPJ P,
ENDR REALI;12/16/72(BGB),14-MAR-73(TVR)------------------------------
;TITLE III - III DISPLAY SUBROUTINES - BGB - JANUARY 1973.
↓A←1↔↓B←2↔↓C←3
INTERN BUFDPY,DPYPTR
BUFDPY: .+2↔=100↔BLOCK =100
INTERN DPYBUF
DPYBUF: DPYBU.↔=2048
DPYBU.: BLOCK =2048
IGNORE: BLOCK 1
SIZBRT: BLOCK 1
DPYCOL: BLOCK 1
DPYPTR: BLOCK 1
BUFEND: BLOCK 1
BUFHD: BLOCK 2 ;UPG ARGUMENT. ;ADDRESS ↔ LENGTH.
DDSAVE: BLOCK 1
;VERNIER III TEXT POSITIONING.
VERNX ←← 14
VERNY ←← 11
;DISPLAY SAIL STRING.
DPYSST↑: POP 16,1↔POP 16,2↔SKIPGE IGNORE↔POPJ P,
HRRZS 2 ;LENGTH OF STRING.
JUMPLE 2,SSRET
ILDB 3,1
IDPB 3,DPYPTR
SOJG 2,.-2
SSRET: HRRZ 1,DPYPTR
CAML 1,BUFEND
SETOM IGNORE
POPJ P,
;SUBRS DPYSET,DPYBIG,DPYBRT ;Set buffer,char. size, brightness*
SUBR(DPYSET,BUFFER) ;Initialize a display buffer *
;____________________________________________________________________
LAC 1,BUFFER↔CDR 2,-1(1) ;BUFFER SIZE.
ADDI 2,-1(1)↔DAC 2,BUFEND
ADDI 1,2↔DAC 1,BUFHD ;POINT TO THIRD WORD.
SETZM IGNORE
SETZM SIZBRT
CLR2: LAC A,BUFHD ;BLIT THE BUFFER WITH THE III-TEXT OPCODE 1.
LACI B,1↔DAC B,1(A)
LACI B,2(A)↔LIPI B,1(A)
BLT B,@BUFEND
PUSH P,(P)↔GO LV3
ENDR DPYSET
SUBR(DPYBIG,SIZE) ;Set character size
;____________________________________________________________________
;USES AC 1
LAC A,SIZE↔DPB A,[POINT 3,SIZBRT,27] ;REMEMBER NEW SIZE
POP1J
ENDR DPYBIG
;____________________________________________________________________
SUBR(DPYBRT,SIZE) ;Set brightness
;USES AC 1
LAC A,SIZE↔DPB A,[POINT 3,SIZBRT,24] ;REMEMBER NEW BRIGHTNESS
POP1J
ENDR DPYBRT
;SUBRS AVECT,AIVECT,RVECT,RIVECT ;Vectors
COMMENT ⊗
The III display processor is a stored program computer,
these III subroutines make a III program using only two display
operations: the long vector operation and the text operation. The
pointer to the display buffer is always maintained as a BYTE POINTER
to the last character displayed. The flag named IGNORE is set when
display buffer overflow occurs and all further display calls are
ignored until the buffer is used. The III instruction formats are
given below, unlike most CPU (but like must display processors of
its day) the immediate data fields are in the left portion of the
instruction and the opcode in the right.
TEXT DISPLAY WORD: ASCII/ABCDE/ + 1
LONG VECTOR WORD: BYTE(11)X,Y(3)BRT,SIZ(7)OPCODE
The long vector opcodes appear in the following four lines: ⊗
SUBR(RIVECT)
GO RIV. ↔ENDR RIVECT
SUBR(RVECT)
GO RV. ↔ENDR RVECT
SUBR(AIVECT)
GO AIV. ↔ENDR AIVECT
SUBR(AVECT)
GO AV. ↔ENDR AVECT
;USES AC 1-3
;DTYO DEPENDS ON THIS
RIV.: SKIPA C,[046] ;RELATIVE INVISIBLE VECTOR.
RV.: LACI C, 006 ↔GO LV0 ;RELATIVE VISIBLE VECTOR.
AIV.: SKIPA C,[146] ;ABSOLUTE INVISIBLE VECTOR.
AV.: LACI C, 106 ;ABSOLUTE VISIBLE VECTOR.
SETZM DPYCOL ;RESET TAB LOCATION
LV0: SKIPGE IGNORE↔POP2J
LV: LAC A,-2(P)↔LAC B,-1(P) ;PICKUP X AND Y.
LVC: DPB A,[POINT 11,C,10] ;PACK X INTO III-WORD.
DPB B,[POINT 11,C,21] ;PACK Y INTO III-WORD.
SKIPE A,SIZBRT ;NEW BRIGHTNESS OR SIZE?
GO [ IOR C,A↔DZM SIZBRT↔GO LV2] ;YES, SET IT
LV2: AOS A,DPYPTR↔DAC C,(A) ;PACK WORD INTO III-BUFFER.
LV3: LIPI A,<(<POINT 7,0,35>)> ;UPDATE DPYPTR...
DAC A,DPYPTR↔LACI A,(A) ;WHICH IS A BYTE-POINTER.
CAML A,BUFEND↔SETOM IGNORE ;CHECK FOR BUFFER OVERFLOW.
POP2J
;SUBRS DPYSTR,DTYO,DPYOUT ;Output string,character, POG *
;--------------------------------------------------------------------
SUBR(DPYSTR,TEXT)
;USES AC 1,3
LAC 3,TEXT↔LIPI 3,440700
L1: ILDB 3↔JUMPE POP1J.
CALL(DTYO,0)↔GO L1
ENDR DPYSTR;---------------------------------------------------------
SUBR(DTYO,CHAR)
;USES AC 1
;DPYSTR DEPENDS ON DTYO NOT CLOBBERING 3
SKIPE SIZBRT
GO [ PUSHP 0↔PUSHP 2↔PUSHP 3
CALL(RIVECT,[0],[0])
POPP 3↔POPP 2↔POPP 0
GO .+1]
LAC 1,CHAR
CAIN 1,15↔DOM DPYCOL
CAIN 1,11↔GO DOTAB
DTYO1: IDPB 1,DPYPTR↔AOS DPYCOL
CDR 1,DPYPTR↔CAML 1,BUFEND
DOM IGNORE↔POP1J
DOTAB: CALL(DTYO,[" "]) ;We got a tab, put out spaces until
LAC 1,DPYCOL ;column is divisible by 8
TRNE 1,7↔GO DOTAB
CDR 1,DPYPTR
POP1J
ENDR DTYO;-----------------------------------------------------------
SUBR(DPYOUT,POG)
COMMENT ⊗------------------------------------------------------------
⊗↔ SKIPN A,BUFHD↔GO L1
LAC 2,DPYPTR↔DAC 2,-2(1)
LACI 2,2(2)↔SUB 2,1↔DAC 2,-1(1)
L1: CDR B,DPYPTR↔SUB B,BUFHD ;BUFFER LENGTH.
AOS B↔DAC B,BUFHD+1
LACM A,POG↔DPB A,[POINT 4,UPGOP,12] ;GLASS TO AC FIELD.
XCT UPGOP
POP1J
UPGOP: 703B8+BUFHD
ENDR DPYOUT;---------------------------------------------------------
;SUBRS OCTDPY,DECDPY,FLODPY ;Numeric display *
;--------------------------------------------------------------------
SUBR(OCTDPY,INTEGER) ;OCTAL NUMBER DISPLAY.
Q←15 ↔ N←13
JFCL↔GO L2
LAC 14,INTEGER↔LAC Q,[POINT 3,14,-1]↔LACI N,6
L1: ILDB Q↔IORI 60↔CALL(DTYO,0)↔SOJG N,L1
CALL(DTYO,[" "])
L2: LAC 14,INTEGER↔LAC Q,[POINT 3,14,17]↔LACI N,6
L3: ILDB Q↔IORI 60↔CALL(DTYO,0)↔SOJG N,L3
POP1J
ENDR OCTDPY;3/25/73(BGB)---------------------------------------------
DECDPY↑:;(INTEGER) ;DECIMAL NUMBER DISPLAY.
BEGIN DECDPY
LAC 1,ARG1↔POP P,-1(P) ;FETCH ARG AND LAC RET. ADR.
L1: JUMPGE 1,L2 ;TEST FOR NEGATIVE NUMBER.
MOVM 2,1↔CALL(DTYO,["-"]) ;PRINT MINUS SIGN.
LAC 1,2
L2: IDIVI 1,12↔PUSH P,2 ;MODULO TEN AND SAVE.
SKIPE 1↔PUSHJ P,L2 ;TEST FOR DONE.
POP P,1↔ADDI 1,60↔CALL(DTYO,1) ;RESTORE & PRINT.
POPJ P,
BEND DECDPY;12/17/72(BGB)--------------------------------------------
SUBR(FLODPY,FLONUM,PLACES) ;FLOATING NUMBER DISPLAY.
LAC FLONUM
JUMPL[CALL(DTYO,["-"])↔LACM FLONUM↔GO .+1]
LACM 2,PLACES↔CAILE 2,6↔LACI 2,6↔DAC 2,PLACES
FMPR[1.↔10.↔100.↔1000.↔10000.↔100000.↔1000000.](2)↔FIXX
IDIV[=1↔=10↔=100↔=1000↔=10000↔=100000↔=1000000](2)
PUSHP 1↔CALL(DECDPY,0)↔POPP 0
LAC 2,PLACES
ADD[=1↔=10↔=100↔=1000↔=10000↔=100000↔=1000000](2)
PUSHP DPYPTR↔CALL(DECDPY,0)↔POPP 1
LACI "."↔IDPB 0,1
POP2J
ENDR FLODPY;12/17/72(BGB)--------------------------------------------
END